home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
MacHack 1994
/
MacHack 1994.toast
/
MacHack™94
/
Talks & Papers
/
Timothy Knox
/
yerk 3.66
/
Module source
/
docmod
< prev
next >
Wrap
Text File
|
1994-06-24
|
12KB
|
430 lines
\ 12.25.93 rfl added need; fwind now moved out of way and dwind selected
\ 1.03.94 rfl fixed copy, paste etc.
:module docmod
// ctl
// ctlwind
// vscroll
// textedit
0 value eop
: getWidth option?
IF -1 -> eop ELSE getvrect: actw drop 15 - 6 / 20 / 20 * 21 - -> eop 2drop THEN ;
: (marks) ( cfa filemk --)
over @ = IF >name dup
8 .r 3 spaces n>count type out eop >
IF cr 0 -> out ELSE 26 out over mod - spaces THEN
ELSE drop
THEN ?pause ;
\ same as 'words'..lists all filemarks
\ hold down option key to get single column
: marks getWidth 0 -> out
base >r hex
'c (marks) filemk trav cr
r> -> base ;
0 value mkCfa \ the file mark cfa
\ define a word to check each cfa in the fmark vocab, and if it is earlier
\ in the dictionary than the cfa of the word we are testing to see which
\ file it is in, then we must have found the mark...set a flag.
: (findMk) \ ( cfa wordcfa -- )
over > IF dup -> mkCfa @ filemk = -> endTrav? ELSE drop THEN ;
\ find first mark above the wordcfa - returns true if mark found
: findFMark \ ( wordcfa -- cfa t or f) - could also be addr
LoCase
'c (findMk) swap trav
UpCase
endTrav? IF mkCfa true ELSE false THEN ;
\ get source name from mark
: srcName ( cfa -- addr len) findFMark not abort" No Mark"
>name n>count ;
: (forget) ( pfa --) dup nfa >line -> dp lfa @ current ! ;
: mforget LoCase [compile] ' (forget) Upcase ;
\ forget to last mark
: FM here findFMark 0= abort" no mark found"
>body (forget) ;
\ reload last file, forgetting to mark
: RL here srcname fm new: loadfile
name: topfile interpret: topfile remove: loadfile ;
\ *** reload sources from named mark
string LoadList \ make the filelist here
string tempStr \ use in place of parmstr, since parmstr defined in Frontend
\ identify all source names from latest to the entered mark and fill filelist
: (files) ( cfa cfa0 --)
over <=
IF dup @ filemk =
IF " // " put: tempStr >name n>count add: tempStr 13 +: tempStr lock: tempStr
get: tempStr start: LoadList insert: LoadList unlock: tempStr
ELSE drop THEN
ELSE drop true -> endTrav?
THEN ;
\ find filenames
: files ( -- pfa) new: tempStr
clear: LoadList 'c (files) locase [compile] ' dup >r upcase 4- latest (trav) r>
release: tempStr ;
: loadKey
next: LoadList 0=
IF rekey 13 THEN ; \ simulate a terminal cr
\ interpret from the scrap
: Doit size: loadlist 0>
IF start: loadlist 'c loadKey -> keyVec THEN sp! mp! quit ;
\ interpret LoadList
: reload loadKey doit ;
\ make file list, forget to the mark, and the reload the list.
\ usage: /// filename
\ will rebuild from 'filename' to latest
: /// new: LoadList files (forget) reload release: LoadList ;
: toScrap 0 call zeroScrap
global teScrpLength w@ 'type TEXT global teScrpHandle @ >ptr +base
call putScrap drop ;
\ 1.31.92 rfl modified recalscroll
\ DISABLE MESSAGE SENT AFTER CLOSED!!!
\ class that is only for displaying scrolling, word wrapped text
\ has a vertical scroll bar attached at right, with grow box.
\ scroll region is entire window minus the scroll bar
:CLASS TeScrollRect <super TextEdit
var myVScroll \ scrollbar ptr
rect boundsRect \ turns out is content region
int atLine \ internal use for keeping text at same line after grow
var myWindow \ used to determine if window is active for scroll bar
:M putScroll: ( n --) put: myVScroll ;M
:M lineHeight: ( -- n) m@ >ptr 24 + w@ ;M
:M nlines: ( -- n) m@ >ptr 94 + w@ ;M
:M putLine: ( n --) put: atLine ;M
\ returns top line
:M where: ( -- line#) getTopY: destrect \ subtract y0 of original dest rect
m@ >ptr getTopY: rect - lineHeight: self / ;M \ get y0 of internal dest rect
\ :M topChar: m@ >ptr 96 + where: self 2* + w@ ;M
\ get number of whole lines
:M visibleLines: ( -- n) ptr: self 8+ size: rect swap drop lineheight: self / ;M
\ boundsRect of two textctls can't be too close vertically: > 4 pixels
:M putRect: { l t r b -- } l t r b put: boundsRect
l 4+ t 2+ r 18 - b 2- putRect: super m@
IF get: destRect drop over visibleLines: self lineHeight: self * +
ptr: self 8+ put: rect
THEN ;M
\ return max first line
:M maxRange: ( -- n) nlines: self visibleLines: self - 1+ ;M
:M new: { myWind -- } myWind put: myWindow
myWind new: super
getBotX: boundsRect 15 - getTopY: boundsRect
size: boundsRect swap drop myWind new: [ obj: myVScroll ]
disable: [ obj: myVScroll ]
1 1 putRange: [ obj: myVScroll ] ;M
:M close: close: [ obj: myVScroll ] close: super 'c docmod munlock ;M
:M draw: pushPort set: [ obj: myWindow ] draw: super popPort ;M
\ move text record to line# as first line in rect
:M moveto: { line# \ y -- } 0
line# maxRange: self 1- min 0 max \ negate \ where we want it to be
where: self \ where are we now?
- lineHeight: self * negate \ translate to pixel offset
m@ >ptr offset: rect line# put: atLine draw: self
where: self 1+ put: [ obj: myVScroll ] ;M
\ recalibrate scroll bar size, range, and set text
:M recalScroll: 1 maxRange: self 1 max
putRange: [ obj: myVScroll ]
nlines: self visibleLines: self > active: [ obj: myWindow ] and
IF enable: [ obj: myVScroll ] THEN
get: atLine maxRange: self 1- min 0 max moveto: self \ stay at about where we were before grow
;M
:M find: { addr len \ myText offset off1 -- offset line T or F }
heap> sarray -> myText new: myText 13 putChar: mytext
getText: super place: myText
start: myText addr len myText indexof: string
IF 1- -> offset
ptr: myText offset + bl parse -> off1 drop
bl parse offset + off1 + offset swap setSelect: self 2drop
limit: myText 1
DO offset i ^elem: myText 0 ^elem: myText - <
IF i leave THEN
LOOP moveto: self recalscroll: self
THEN release: myText dispose> myText ;M
\ recal really slows things down
:M addText: ( addr len --) addtext: super recalScroll: self ;M
:M put: ( addr len --) clear: super addText: self ;M
:M grow: ( l t r b -- ) where: self put: atLine
putRect: self
16 size: boundsRect swap drop 15 - size: [ obj: myVScroll ]
getBotX: boundsRect 15 - getTopY: boundsRect moveto: [ obj: myVScroll ]
recal: self
recalScroll: self ( draw: self) ;M
:M activate: activate: super enable: [ obj: myVScroll ] ;M
:M deactivate: deactivate: super disable: [ obj: myVScroll ] ;M
\ :M exec: activate: self click: super ;M
;CLASS
\ class to contain the teScrollRect
:CLASS ScrollWind <super ctlWind
var myTextPane \ pointer to teScrollRect
:M putPane: ( n --) put: myTextPane ;M
:M close: close: [ obj: myTextPane ] close: super ;M
\ draw only the grow box, no horizontal scroll lines
:M clipGrow: { \ b r scratchRgn -- }
get: growFlg
IF 0 call NewRgn -> scratchRgn
scratchRgn call getClip
getRect: self 2swap 2drop -> b -> r
r 15 - 0 r b put: tempRect clip: tempRect
@xy (abs) call DrawGrowIcon gotoxy
scratchRgn call setClip scratchRgn call disposeRgn
THEN ;M
\ same draw as window, except that we clip the grow rect when drawing it.
:M DRAW: get: fPrect
(abs) call BeginUpdate
savePort @xy set: self
clipGrow: self
exec: draw gotoxy \ call user draw routine
(abs) call EndUpdate
put: fPrect
draw: [ obj: myTextPane ] restport ;M
\ ( -- ) response to activate event - want to draw only grow rect
:M ENABLE:
^base -> actW \ commence idle handler
set: self
clipGrow: self
activate: [ obj: myTextPane ]
exec: Enact ;M
:M disable: deactivate: [ obj: myTextPane ]
0 -> actw clipGrow: self exec: deact ;M
:M (grow): getVrect: self put: temprect -4 0 offset: temprect clear: temprect
getrect: self 2+ swap 1+ swap put: temprect -1 -1 offset: temprect
get: temprect grow: [ obj: myTextPane ] ;M
:M grow: Get: growFlg
IF 0 (abs) Where: fEvent abs: growrect
call GrowWindow -dup
IF unpack size: self (grow): [ ^base ] setView: self THEN
THEN select: self ;M
:M new: alive: super not
IF new: super ^base new: [ obj: myTextPane ]
setLimits: self \ activate: [ obj: myTextPane ]
(grow): [ ^base ]
THEN ( select: self) ;M
:M addText: ( addr len --) alive: self
IF pushPort >r set: self addText: [ obj: myTextPane ] r> popPort
ELSE 2drop
THEN ;M
:M print: ( addr len --) alive: self
IF pushPort >r set: self put: [ obj: myTextPane ] r> popPort
ELSE 2drop
THEN ;M
:M cut: teCut: [ obj: myTextPane ] toScrap ;M
:M copy: teCopy: [ obj: myTextPane ] toScrap ;M
:M paste: tePaste: [ obj: myTextPane ] ;M
:M key: { char -- } char $ ff and -> char
command?
IF char
CASE
ascii c char ascii C = or OF Copy: self ENDOF
ascii x char ascii X = or OF Cut: self ENDOF
ascii v char ascii V = or OF paste: self ENDOF
ENDCASE
ELSE char key: [ obj: myTextPane ]
THEN ;M
:M content:
pushPort ^base set: grafPort ^base ctlhit? not
IF select: self click: [ obj: myTextPane ]
THEN popPort ;M
:M idle: ptIn: [ obj: myTextPane ]
IF ibeamCurs idle: [ obj: myTextPane ] ELSE arrowCurs THEN exec: idle ;M
;CLASS
\ instantiate objects
ScrollWind dwind
tescrollrect dPane
vscroll dscroll
dscroll putScroll: dPane
dPane putPane: dwind
\ 2 2 270 120 putrect: dPane
270 61 640 300 true setgrow: dwind
: buildDWind pushPort alive: dwind not
IF 2 40 542 200 put: temprect
temprect 0 0 docwind false true new: dwind
THEN dup call selectWindow popPort
1 'c docmod 12 + @ $ ffffff and c! ; \ force the module to be locked
\ until window is closed
: lndn get: myCtl 1+ dup put: myCtl maxRange: dPane <=
IF 0 lineHeight: dPane negate scroll: dPane THEN ;
: lnup get: myCtl 1- dup put: myCtl 0>
IF 0 lineHeight: dPane scroll: dPane THEN ;
: pgdn get: myCtl visibleLines: dPane 1- + put: myCtl get: myCtl 1- moveto: dPane ;
: pgup get: myCtl visibleLines: dPane 1- - put: myCtl get: myCtl 1- moveto: dPane ;
: doth get: myCtl put: myCtl get: myCtl 1- moveto: dPane ;
5 'cfas lnup lndn pgup pgdn doth actions: dscroll
0 value srcOpen \ store mkcfa or 0.
: NoSrc false -> srcOpen ;
: dwindInterp \ \ for testing textctl entries
BEGIN
next: fevent
IF active: dwind
IF drop key: dwind ELSE become quit THEN
THEN
AGAIN ;
2 'cfas null null setAct: dwind
4 'cfas NoSrc dwindInterp null null actions: dwind
: loadr ( addr len --)
new: loadfile
name: topFile
open: topFile dup konstant fnfErr =
abort" file not in pathList"
abort" file error"
topFile size: topFile read: tempstr drop
builddwind
getName: topFile title: dwind
remove: loadfile ;
: moveFwind { \ l t r b -- }
set: dwind 0 l->g unpack -> t drop
getRect: dwind ++> t drop 2drop
getRect: fwind -> b -> r 2drop
screenbits 20 - t b + min -> b drop 2drop
r b t - size: fwind
2 t 20 + moveto: fwind set: fwind select: fwind
fixGrow: fwind enable: fwind ;
: see { \ xline wordPfa -- }
docs 0= abort" +docs not set"
@word count sfind
IF drop -> wordPfa
wordPfa nfa >line w@ extend -> xline
xline -1 <>
IF wordPfa findfmark
IF srcOpen <>
IF new: tempStr
mkCFA >name n>count loadr mkCFA -> srcOpen
xline putLine: dpane
lock: tempstr get: tempstr print: dwind unlock: tempstr
release: tempstr
ELSE xline moveto: dpane
THEN
moveFwind show: dwind
ELSE ." word not marked"
THEN
ELSE ." word not marked"
THEN
ELSE ." not found"
THEN ;
\ : qhit? ( n n - b) drop $ ff and ascii q = ;
\
\ \ for testing textctl entries
\ : kk BEGIN
\ next: fevent
\ IF actw fwind =
\ IF qhit?
\ IF exit THEN
\ ELSE drop key: actw
\ THEN
\ THEN
\ AGAIN ;
\ *************************
hex \ compare two strings case insensitive
create s=' ( addr len addr len -- tf)
201f w, \ move.l (sp)+,d0
225f w, \ movea.l (sp)+,a1
241f w, \ move.l (sp)+,d2
2057 w, \ movea.l (sp),a0
4840 w, \ swap d0
3002 w, \ move.w d2,d0
4840 w, \ swap d0
d1cb w, \ adda.l a3,a0
d3cb w, \ adda.l a3,a1
a03c w, \ call equalString
0a00 w, 1 w, \ eori.b #1,d0
2e80 w, \ move.l d0,(sp)
next,
decimal
: (include) { cfa nameAddr -- }
cfa @ filemk =
IF cfa >name n>count str255 -base count
nameAddr count s=' -> endTrav?
THEN ;
: need { \ lcurs -- }
docs 0= abort" +docs not set"
new: loadfile setName: topfile
'c (include) getName: topfile drop 1- trav endTrav? not
IF curs -> lcurs -curs \ Preserve cursor status
getName: topFile 3 tfont 1 tface type# 173 ( Loading: ) type 0 tface 4 tfont cr
interpret: topFile
lcurs -> curs \ Restore cursor status
THEN remove: loadFile ;
;module